home *** CD-ROM | disk | FTP | other *** search
/ Mac Magazin/MacEasy 32 / Mac Magazin and MacEasy Magazine CD - Issue 32.iso / Multimedia / MIDI / MidiChaos_15 Folder / MidiChaos_1.5 / Source / Tools / midifile_vref < prev    next >
Text File  |  1990-10-25  |  14KB  |  636 lines
  1. \ MIDI File Standard Support
  2. \
  3. \ This code allows the sharing of music data between aplications.
  4. \
  5. \ Author: Phil Burk
  6. \ Copyright 1989 Phil Burk
  7. \
  8. \ MOD: PLB 6/11/90 Added SWAP to $MF.LOAD.SHAPE
  9. \ MOD: PLB 10/23/90 Added $MF.OPEN.VR
  10.  
  11. ANEW TASK-MIDIFILE
  12. decimal
  13.  
  14. \ Variable Length Number Conversion
  15. variable VLN-PAD  ( accumulator for variable length number )
  16. variable VLN-COUNT  ( number of bytes )
  17.  
  18. : BYTE>VLN  ( byte -- , add byte to VLN buffer )
  19.     vln-count @ 0>
  20.     IF $ 80 or     ( set continuation bit )
  21.     THEN
  22.     vln-pad 4+ vln-count @ 1+ dup vln-count !
  23.     - c!
  24. ;
  25.  
  26. : NUMBER->VLN  ( N -- address count , convert )
  27.     dup $ 0FFFFFFF >
  28.     IF ." NUMBER->VL - Number too big for MIDI File! = "
  29.        dup .hex cr
  30.        $ 0FFFFFFF and
  31.     THEN
  32.     dup 0<
  33.     IF ." NUMBER->VL - Negative length or time! = "
  34.        dup .hex cr
  35.        drop 0
  36.     THEN
  37.     vln-count off
  38.     BEGIN dup $ 7F and byte>vln
  39.         -7 shift dup 0=
  40.     UNTIL drop
  41.     vln-pad 4+ vln-count @ dup>r - r>
  42. ;
  43.  
  44. : VLN.CLEAR ( -- , clear for read )
  45.     vln-count off vln-pad off
  46. ;
  47.  
  48. : VLN.ACCUM  ( byte -- accumulate another byte )
  49.     $ 7F and
  50.     vln-pad @ 7 shift or vln-pad !
  51. ;
  52.  
  53. \ -------------------------------------------------
  54. variable MF-BYTESLEFT
  55. variable MF-EVENT-TIME
  56. variable MF-#DATA
  57.  
  58. : CHKID ( <chkid> <name> -- , define chkid )
  59.     32 lword count drop odd@ constant
  60. ;
  61.  
  62. chkid MThd 'MThd'
  63. chkid MTrk 'MTrk'
  64. host=mac .IF
  65. \ These next two are only used on the Mac which has a File Type
  66. \ and Creator!
  67. chkid MIDI 'MIDI'_CREATOR
  68. chkid Midi 'MIDI'_TYPE
  69. .THEN
  70.  
  71.  
  72. variable mf-FILEID
  73. 16 constant MF_PAD_SIZE
  74. variable mf-PAD mf_pad_size allot
  75.  
  76. DEFER MF.PROCESS.TRACK   ( size track# -- )
  77. DEFER MF.ERROR
  78.  
  79. ' abort is mf.error
  80.  
  81. : .CHKID ( 'chkid' -- , print chunk id )
  82.     pad ! pad 4 type
  83. ;
  84.  
  85. : $MF.OPEN  ( $filename -- )
  86.     dup c@ 0=
  87.     IF drop ." $MF.OPEN - No filename given!" cr mf.error
  88.     THEN
  89.     dup $fopen dup 0=
  90.     IF drop ." Couldn't open file: " $type cr mf.error
  91.     THEN
  92.     nip mf-fileid !
  93. ;
  94.  
  95. host=mac .IF
  96. : $MF.OPEN.VR  ( $filename volref -- )
  97.     over c@ 0=
  98.     IF drop ." $MF.OPEN.VR - No filename given!" cr mf.error
  99.     THEN
  100.     over swap $fopen_vr dup 0=
  101.     IF drop ." Couldn't open file: " $type cr mf.error
  102.     THEN
  103.     nip mf-fileid !
  104. ;
  105.  
  106. \ The Macintosh needs to have the file creator and type set!!
  107. : MF.SET.FILEINFO  ( -- , set creator and type )
  108.     'midi'_creator file-creator !
  109.     'midi'_type file-type !
  110. ;
  111. .ELSE
  112. : MF.SET.FILEINFO  ( -- , set creator and type )
  113. ;
  114. .THEN
  115.  
  116. : $MF.CREATE  ( $filename vref -- , create new file )
  117.     mf.set.fileinfo
  118.     new $mf.open.vr
  119. ;
  120. : MF.SET.FILE  ( fileid -- )
  121.     mf-fileid !
  122. ;
  123.  
  124. : MF.READ ( addr #bytes -- #bytes , read from open mf file)
  125.     dup negate mf-bytesleft +!
  126.     mf-fileid @ -rot    fread
  127. ;
  128.  
  129. : MF.READ.CHKID  ( -- size chkid )
  130.     dup>r mf-pad 8 mf.read
  131.     8 -
  132.     IF ." Truncated chunk " r@ .chkid cr mf.error
  133.     THEN
  134.     rdrop
  135.     mf-pad cell+ @
  136.     mf-pad @
  137. ;
  138.  
  139.  
  140. : MF.WRITE ( addr #bytes -- #bytes , write to open mf file)
  141.     mf-fileid @ -rot    fwrite
  142. ;
  143.  
  144. : MF.WRITE? ( addr #bytes -- , write to open mf file or mf.ERROR)
  145.     dup>r mf.write r> -
  146.     IF ." mf.WRITE? failed!" cr mf.error
  147.     THEN
  148. ;
  149.  
  150. : MF.READ.BYTE ( -- byte )
  151.     mf-pad 1 mf.read 1-
  152.     IF ." MF.READ.BYTE - Unexpected EOF!" cr mf.error
  153.     THEN
  154.     mf-pad c@
  155. ;
  156.  
  157. : MF.WRITE.BYTE ( byte -- )
  158.     mf-pad c! mf-pad 1 mf.write?
  159. ;
  160.  
  161. : MF.WRITE.WORD ( 16word -- )
  162.     mf-pad w! mf-pad 2 mf.write?
  163. ;
  164.  
  165. : MF.READ.WORD ( -- 16word )
  166.     mf-pad 2 mf.read 2-
  167.     IF ." MF.READ.WORD - Unexpected EOF!" cr mf.error
  168.     THEN
  169.     mf-pad w@
  170. ;
  171.  
  172. : MF.WRITE.CHKID  ( size chkid -- , write chunk header )
  173.     mf-pad !
  174.     mf-pad cell+ !
  175.     mf-pad 8 mf.write?
  176. ;
  177.  
  178. : MF.WRITE.CHUNK  ( address size chkid -- , write complete chunk )
  179.     over >r mf.write.chkid
  180.     r> mf.write?
  181. ;
  182.  
  183. : MF.READ.TYPE  ( -- typeid )
  184.     mf-pad 4 mf.read
  185.     4 -
  186.     IF ." Truncated type!" cr mf.error
  187.     THEN
  188.     mf-pad @
  189. ;
  190.  
  191. : MF.WHERE ( -- current_pos , in file )
  192.     mf-fileid @ 0 offset_current fseek
  193. ;
  194.  
  195. : MF.SEEK ( position -- , in file )
  196.     mf-fileid @ swap offset_beginning fseek drop
  197. ;
  198.  
  199. : MF.SKIP  ( n -- , skip n bytes in file )
  200.     dup negate mf-bytesleft +!
  201.     mf-fileid @ swap offset_current fseek drop
  202. ;
  203.  
  204. : MF.CLOSE
  205.     mf-fileid @ ?dup
  206.     IF  fclose
  207.         0 mf-fileid !
  208.     THEN
  209. ;
  210.  
  211. variable MF-NTRKS    \ number of tracks in file
  212. variable MF-FORMAT   \ file format = 0 | 1 | 2
  213. variable MF-DIVISION \ packed division
  214.  
  215. : MF.PROCESS.HEADER  ( size -- )
  216.     dup mf_pad_size >
  217.     IF ." MF.PROCESS.HEADER - Bad Header Size = "
  218.        dup . cr mf.error
  219.     THEN
  220.     mf-pad swap mf.read drop
  221.     mf-pad w@ mf-format !
  222.     mf-pad 2+ w@ mf-ntrks !
  223.     mf-pad 4+ w@ mf-division !
  224. ;
  225.  
  226. : MF.SCAN.HEADER ( -- , read header )
  227.     mf.read.chkid  ( -- size chkid)
  228.     'MThd' =
  229.     IF mf.process.header
  230.     ELSE ." MF.SCAN - Headerless MIDIFile!" cr mf.error
  231.     THEN
  232. ;
  233.  
  234. : MF.SCAN.TRACKS ( -- , read tracks )
  235. \ This word leaves the file position just after the chunk data.
  236.     mf-ntrks @ 0
  237.     DO mf.read.chkid 'MTrk' =
  238.        IF dup mf.where + >r
  239.           i mf.process.track
  240.           r> mf.seek ( move past chunk)
  241.        ELSE ." MF.SCAN - Unexpected CHKID!" cr mf.error
  242.        THEN
  243.     LOOP
  244. ;
  245.  
  246. : MF.SCAN ( -- , read header then tracks)
  247.     mf.scan.header
  248.     mf.scan.tracks
  249. ;
  250.  
  251. : MF.VALIDATE ( -- ok? , make sure open file has header chunk )
  252.     mf.where
  253.     0 mf.seek
  254.     mf.read.type 'MThd' =
  255.     swap mf.seek
  256. ;
  257.  
  258. : (MF.DOFILE) ( -- ,process current file )
  259.     mf.validate
  260.     IF  mf.scan
  261.     ELSE ."  Not a MIDIFile!" cr
  262.         mf.close mf.error
  263.     THEN
  264.     mf.close
  265. ;
  266.  
  267. : $MF.DOFILE ( $filename -- , process file using deferred words)
  268.     $mf.open (mf.dofile)
  269. ;
  270.  
  271. host=mac .IF
  272. : $MF.DOFILE.VR ( $filename volref -- , process file using deferred words)
  273.     $mf.open.vr (mf.dofile)
  274. ;
  275. .THEN
  276.  
  277. : MF.DOFILE ( <filename> -- )
  278.     fileword $mf.dofile
  279. ;
  280.  
  281. : MF.READ.VLN ( -- vln , read vln from file )
  282.     vln.clear
  283.     BEGIN mf.read.byte dup $ 80 and
  284.     WHILE vln.accum
  285.     REPEAT vln.accum
  286.     vln-pad @
  287. ;
  288.  
  289. defer MF.PROCESS.META  ( size metaID -- , process Meta event )
  290. defer MF.PROCESS.SYSEX
  291. defer MF.PROCESS.ESCAPE
  292.  
  293. variable MF-SEQUENCE#
  294. variable MF-CHANNEL
  295. : MF.LOOK.TEXT ( size metaID -- , read and show text )
  296.     >newline ." MetaEvent = " . cr
  297.     pad swap mf.read
  298.     pad swap type cr
  299. ;
  300.  
  301. : MF.HANDLE.META  ( size MetaID -- default Meta event handler )
  302.     dup $ 01 $ 0f within?
  303.     IF mf.look.text
  304.     ELSE CASE
  305.         $ 00 OF drop mf.read.word mf-sequence# ! ENDOF
  306.         $ 20 OF drop mf.read.byte 1+ mf-channel ! ENDOF
  307.           ." MetaEvent = " dup . cr
  308.           swap mf.skip  ( skip over other event types )
  309.         ENDCASE
  310.     THEN
  311. ;
  312.  
  313. ' mf.handle.meta is MF.PROCESS.META
  314. ' mf.skip is MF.PROCESS.SYSEX
  315. ' mf.skip is MF.PROCESS.ESCAPE
  316.  
  317. : MF.PARSE.EVENT ( -- , parse MIDI event )
  318.     mf.read.byte dup $ 80 and  ( is it a command or running status data )
  319.     IF CASE
  320.         $ FF OF mf.read.byte  ( get type )
  321.                 mf.read.vln ( get size ) swap mf.process.meta ENDOF
  322.         $ F0 OF ." F0 byte" cr mf.read.vln mf.process.sysex ENDOF
  323.         $ F7 OF ." F7 byte" cr mf.read.vln mf.process.escape ENDOF
  324. \ Regular command.
  325.     dup mp.#bytes mf-#data !
  326.         dup mp.handle.command
  327.         mf-#data @ 0
  328.         DO mf.read.byte mp.handle.data
  329.         LOOP
  330.        ENDCASE
  331.     ELSE 
  332.         mp.handle.data  ( call MIDI parser with byte read )
  333.         mf-#data @ 1- 0 max 0
  334.         DO mf.read.byte mp.handle.data
  335.         LOOP
  336.     THEN
  337. ;
  338.  
  339. : MF.PARSE.TRACK  ( size track# -- )
  340.     drop mf-bytesleft !
  341.     0 mf-event-time !
  342.     BEGIN mf.read.vln mf-event-time +!
  343.           mf.parse.event
  344.           mf-bytesleft @ 1 <
  345.     UNTIL
  346. ;
  347.  
  348. \ Some Track Handlers
  349. : MF.PRINT.NOTEON ( note velocity -- )
  350.           ?pause
  351.     mf-event-time @ 4 .r ." , "
  352.     ." ON  N,V = " swap . . cr
  353. ;
  354. : MF.PRINT.NOTEOFF ( note velocity -- )
  355.           ?pause
  356.     mf-event-time @ 4 .r ." , "
  357.     ." OFF N,V = " swap . . cr
  358. ;
  359.  
  360. : MF.PRINT.TRACK  ( size track# -- )
  361.     2dup
  362.     >newline dup 0=
  363.     IF ." MIDIFile Format = " mf-format @ . cr
  364.        ."        Division = $" mf-division @ dup .hex . cr
  365.     THEN
  366.     ." Track# " . ."  is " . ."  bytes." cr
  367.     'c mf.print.noteon mp-on-vector !
  368.     'c mf.print.noteoff mp-off-vector !
  369.     mf.parse.track
  370.     mp.reset
  371. ;
  372.  
  373. ' mf.print.track is mf.process.track
  374.  
  375. : MF.CHECK ( <filename> -- , print chunks )
  376.     what's mf.process.track
  377.     ' mf.print.track is mf.process.track
  378.     mf.dofile
  379.     is mf.process.track
  380. ;
  381.  
  382. \ Track Handler that loads a shape -----------------------
  383. variable MF-TRACK-CHOSEN
  384. ob.shape MF-SHAPE
  385.  
  386. : MF.LOAD.NOTEON ( note velocity -- )
  387.     mf-shape ensure.room
  388.     mf-event-time @ -rot add: mf-shape
  389. ;
  390.  
  391. : MF.LOAD.NOTEOFF ( note velocity -- )
  392.     mf-shape ensure.room
  393.     drop mf-event-time @ swap 0 add: mf-shape
  394. ;
  395.  
  396. : MF.LOAD.TRACK ( size track# -- )
  397.     max.elements: mf-shape 0=
  398.     IF 64 3 new: mf-shape
  399.     ELSE clear: mf-shape
  400.     THEN
  401.     'c mf.load.noteon mp-on-vector !
  402.     'c mf.load.noteoff mp-off-vector !
  403.     mf.parse.track
  404. ;
  405.  
  406. : MF.PICK.TRACK  ( size track# -- )
  407.     dup mf-track-chosen @ =
  408.     IF mf.load.track
  409.     ELSE 2drop
  410.     THEN
  411. ;
  412.  
  413. : $MF.LOAD.SHAPE  ( track# $filename -- , load track into mf-shape )
  414.     swap mf-track-chosen !
  415.     what's mf.process.track  SWAP  ( -- oldcfa $filename )
  416.     'c mf.pick.track is mf.process.track
  417.     $mf.dofile
  418.     is mf.process.track
  419. ;
  420.  
  421. : MF.LOAD.SHAPE  ( track# <filename> -- , load track into mf-shape )
  422.     fileword $mf.load.shape
  423. ;
  424.  
  425. : LOAD.ABS.SHAPE  ( shape <filename> -- )
  426.     0 mf.load.shape
  427.     clone: mf-shape
  428.     free: mf-shape
  429. ;
  430.  
  431. \ -------------------------------------------------
  432.  
  433. \ Tools for writing a MIDIFile.
  434. : MF.WRITE.HEADER  ( format ntrks division -- )
  435.     6 'MThd' mf.write.chkid
  436.     mf-pad 4+ w!  ( division )
  437.     over 0=
  438.     IF drop 1  ( force NTRKS to 1 for format zero )
  439.     THEN
  440.     mf-pad 2+ w!  ( ntrks )
  441.     mf-pad    w!  ( format )
  442.     mf-pad 6 mf.write?
  443. ;
  444.  
  445. : MF.BEGIN.TRACK  ( -- curpos , write track start )
  446.     0 'MTrk' mf.write.chkid
  447.     mf.where
  448.     0 mf-event-time !
  449. ;
  450.  
  451. : MF.WRITE.VLN ( n -- , write variable length quantity )
  452.     number->vln mf.write?
  453. ;
  454.  
  455. : MF.WRITE.TIME ( time -- , write time as vln delta )
  456.     dup mf-event-time @ - mf.write.vln
  457.     mf-event-time !
  458. ;
  459.  
  460. : MF.WRITE.EVENT  ( addr count time -- , write MIDI event )
  461. \ This might be called from custom MIDI.FLUSH
  462.     mf.write.time
  463.     mf.write?
  464. ;
  465.  
  466. variable MF-EVENT-PAD
  467.  
  468. : MF.WRITE.META  ( addr count event-type -- )
  469.     mf-event-time @ mf.write.time
  470.     $ FF mf.write.byte
  471.     mf.write.byte  ( event type )
  472.     dup mf.write.vln  ( len )
  473.     mf.write?
  474. ;
  475.  
  476. : MF.WRITE.SYSEX  ( addr count -- )
  477.     mf-event-time @ mf.write.time
  478.     $ F0 mf.write.byte
  479.     dup mf.write.vln  ( len )
  480.     mf.write?
  481. ;
  482.  
  483. : MF.WRITE.ESCAPE  ( addr count -- )
  484.     mf-event-time @ mf.write.time
  485.     $ F0 mf.write.byte
  486.     dup mf.write.vln  ( len )
  487.     mf.write?
  488. ;
  489.  
  490. : MF.WRITE.SEQ#  ( seq#  -- )
  491.     mf-event-pad w!
  492.     mf-event-pad 2 0 mf.write.meta
  493. ;
  494.  
  495. : MF.WRITE.END  ( -- , write end of track )
  496.     mf-event-pad 0
  497.     $ 2F mf.write.meta
  498. ;
  499.  
  500. : MF.END.TRACK  ( startpos -- , write length to track beginning )
  501.     mf.where dup>r  ( so we can return )
  502.     over -   ( -- start #bytes )
  503.     swap cell- mf.seek
  504.     mf-pad ! mf-pad 4 mf.write?
  505.     r> mf.seek
  506. ;
  507.  
  508. : MF.CVM+2D ( time d1 d2 cvm -- )
  509.     mf-event-pad c!
  510.     mf-event-pad 2+ c!
  511.     mf-event-pad 1+ c!
  512.     mf-event-pad 3 rot mf.write.event
  513. ;
  514.  
  515. : MF.WRITE.NOTEON ( time note velocity -- )
  516.     $ 90 mf.cvm+2d
  517. ;
  518.  
  519. : MF.WRITE.NOTEOFF ( time note velocity -- )
  520.     $ 80 mf.cvm+2d
  521. ;
  522.  
  523. : $MF.BEGIN.FORMAT0  ( $name vref -- pos , begin format0 file )
  524.     $mf.create
  525.     0 1 ticks/beat @ mf.write.header
  526.     mf.begin.track  ( startpos )
  527. ;
  528.  
  529. : MF.BEGIN.FORMAT0  ( <name> -- pos , begin format0 file )
  530.     fileword $mf.begin.format0
  531. ;
  532.  
  533. : MF.END.FORMAT0  ( pos -- , begin format0 file )
  534.     mf.write.end
  535.     mf.end.track
  536.     mf.close
  537. ;
  538.  
  539. : MF.WRITE.ABS.SHAPE { shape -- , assume shape Nx3+ absolute time }
  540. \ Assume separate note on/off in shape
  541.     shape reset: []
  542.     shape many: [] 0
  543.     DO i 0 shape ed.at: [] ( -- time )
  544.        i 1 shape ed.at: [] ( -- time note )
  545.        i 2 shape ed.at: [] ( -- time note vel )
  546.        dup 0=
  547.        IF mf.write.noteoff
  548.        ELSE mf.write.noteon
  549.        THEN
  550.     LOOP
  551. ;
  552.  
  553. variable MF-SHAPE-TIME
  554.  
  555. : MF.WRITE.REL.SHAPE { shape -- , assume shape Nx3 relative time }
  556.     0 mf-shape-time !
  557.     shape reset: []
  558.     shape many: [] 0
  559.     DO mf-shape-time @
  560.        i 1 shape ed.at: [] ( -- time note )
  561.        i 2 shape ed.at: [] ( -- time note vel )
  562.        mf.write.noteon
  563.        i 0 shape ed.at: [] ( -- reltime )
  564.        dup 2/ mf-shape-time @ +
  565.        i 1 shape ed.at: [] ( -- rt time note )
  566.        i 2 shape ed.at: [] ( -- rt time note vel )
  567.        mf.write.noteoff
  568.        mf-shape-time +!
  569.     LOOP
  570. ;
  571.  
  572. : SAVE.REL.SHAPE  ( shape <name> -- , complete file output )
  573. \ This word writes out a relative time, 1event/note shape
  574. \ as note on,off
  575.     mf.begin.format0
  576.     swap mf.write.rel.shape
  577.     mf.end.format0
  578. ;
  579.  
  580. : SAVE.ABS.SHAPE  ( shape <name> -- , complete file output )
  581. \ This word writes out a shape as note on,off
  582.     mf.begin.format0
  583.     swap mf.write.abs.shape
  584.     mf.end.format0
  585. ;
  586.  
  587. : MF.WRITE.TIMESIG  ( nn dd cc bb -- )
  588.     mf-event-pad 3 + c!  ( time sig, numerator )
  589.     mf-event-pad 2+  c!  ( denom log2 )
  590.     mf-event-pad 1+  c!  ( MIDI clocks/metronome click )
  591.     mf-event-pad     c!  ( 32nd notes in 24 clocks )
  592.     mf-event-pad 4 $ 58 mf.write.meta
  593. ;
  594.     
  595. : MF.WRITE.TEMPO  ( mics/beat -- )
  596.     mf-event-pad !
  597.     mf-event-pad 1+ 3 $ 51 mf.write.meta
  598. ;
  599.  
  600. \ Capture all MIDI output to a Format0 file
  601. variable MF-START-POS
  602. variable MF-FIRST-WRITE
  603.  
  604. : (MF.CAPTURED>FILE)  ( -- write captured MIDI to file )
  605.     0 0 ed.at: captured-midi mf-event-time !
  606.     many: captured-midi 0
  607.     DO i get: captured-midi midi.unpack
  608.        rot mf.write.event
  609.     LOOP
  610.     mf-start-pos @ mf.end.format0
  611. ;
  612.  
  613. : }MIDIFILE  ( -- )
  614.     if-capturing @
  615.     IF  (mf.captured>file)
  616.         }capture
  617.     THEN
  618. ;
  619.  
  620. : $CAPTURED>MIDIFILE  ( $filename -- )
  621.     $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
  622.     (mf.captured>file)
  623. ;
  624.  
  625. : $MIDIFILE{  ( $filename vref -- , start capturing MIDI data )
  626.     }midifile
  627.     $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
  628.     capture{
  629. ;
  630.  
  631. : MIDIFILE{ ( <name> -- )
  632.     fileword $midifile{
  633. ;
  634.  
  635. if.forgotten }midifile
  636.